home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / comp-exc.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  5.7 KB  |  143 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: comp-exc.scm,v 1.8 1992/09/09 20:30:50 jmiller Exp $
  39.  
  40. ;;;; More of the compiler: exception handler special forms
  41. ;;;;
  42. ;;;; HANDLER-BIND, HANDLER-CASE
  43.  
  44. (define (compile-one-binding module-vars bound-vars really-compile)
  45.   (lambda (type compiled-func compiled-form keywords continue)
  46.     (let ((test (dylan::find-keyword
  47.          keywords 'TEST:
  48.          (lambda () '(METHOD (CONDITION) CONDITION #T))))
  49.       (desc (dylan::find-keyword
  50.          keywords 'DESCRIPTION:
  51.          (lambda () '(METHOD (STREAM) STREAM #F)))))
  52.       (compile-forms (list type test desc)
  53.              module-vars bound-vars really-compile #F
  54.              (lambda (comp-handler-spec module-vars)
  55.                (continue
  56.             `(DYLAN::HANDLER-BIND
  57.               ,(car comp-handler-spec)        ; Type
  58.               ,compiled-func            ; Function
  59.               ,(cadr comp-handler-spec)        ; Test
  60.               ,(caddr comp-handler-spec)        ; Description
  61.               (LAMBDA () ,compiled-form))
  62.             module-vars))))))
  63.  
  64. (define (compile-HANDLER-BIND-form
  65.      e module-vars bound-vars really-compile multiple-values? continue)
  66.   (must-be-list-of-at-least-length e 1 "HANDLER-BIND: bad syntax")
  67.   (let ((handler-spec (car e))
  68.     (form (if (null? (cdr e)) #F `(BEGIN ,@(cdr e)))))
  69.     (must-be-list-of-at-least-length
  70.      handler-spec 2 "HANDLER-BIND: bad syntax for handler specification")
  71.     (let ((keywords (cddr handler-spec)))
  72.       (validate-keywords keywords '(TEST: DESCRIPTION:) dylan::error)
  73.       (let ((type (car handler-spec))
  74.         (func (cadr handler-spec)))
  75.     (compile-forms (list func form)    ; Form is a reduction
  76.                module-vars bound-vars
  77.                really-compile multiple-values?
  78.                (lambda (compiled-func-and-forms module-vars)
  79.              ((compile-one-binding module-vars bound-vars
  80.                            really-compile)
  81.               type
  82.               (car compiled-func-and-forms)
  83.               (cadr compiled-func-and-forms)
  84.               keywords
  85.               continue)))))))
  86.  
  87. (define (compile-HANDLER-CASE-form
  88.      e module-vars bound-vars really-compile multiple-values? continue)
  89.   (must-be-list-of-at-least-length e 1 "HANDLER-CASE: bad syntax")
  90.   (let ((protected-form (car e))
  91.     (protections (cdr e)))
  92.     (for-each (lambda (protection)
  93.         (must-be-list-of-at-least-length
  94.          protection 1
  95.          "HANDLER-CASE: bad protection clause")
  96.         (must-be-list-of-at-least-length
  97.          (car protection) 1
  98.          "HANDLER-CASE: bad handler description"))
  99.           protections)
  100.     (really-compile protected-form module-vars bound-vars multiple-values?
  101.       (lambda (compiled-form module-vars)
  102.     (let loop ((protections protections)
  103.            (code `(LET ((!HANDLER-CASE:VALUE ,compiled-form))
  104.                 (!HANDLER-CASE:EXIT
  105.                  (LAMBDA () !HANDLER-CASE:VALUE))))
  106.            (module-vars module-vars))
  107.       (if (null? protections)
  108.           (continue
  109.            `((CALL-WITH-CURRENT-CONTINUATION
  110.           (LAMBDA (!HANDLER-CASE:EXIT) ,code)))
  111.            module-vars)
  112.           (let* ((this-binding (car protections))
  113.              (protection (car this-binding))
  114.              (forms (cdr this-binding))
  115.              (type (car protection))
  116.              (keywords (cdr protection))
  117.              (condition
  118.               (dylan::find-keyword keywords 'CONDITION:
  119.                        (lambda () #F))))
  120.         (really-compile
  121.          (if forms `(BEGIN ,@forms) #F) module-vars
  122.          (if condition (cons condition bound-vars) bound-vars)
  123.          multiple-values?
  124.          (lambda (compiled-function-body module-vars)
  125.            ((compile-one-binding module-vars bound-vars really-compile)
  126.             type
  127.             `(LAMBDA (!HANDLER-CASE:MULTIPLE-VALUES
  128.                   !NEXT-METHOD
  129.                   ,(or condition '!CONDITION)
  130.                   !NEXT-HANDLER)
  131.                !HANDLER-CASE:MULTIPLE-VALUES ; Ignore
  132.                !NEXT-METHOD    ; Ignore
  133.                !NEXT-HANDLER    ; Ignore
  134.                ,(or condition '!CONDITION) ; Ignore
  135.                (!HANDLER-CASE:EXIT
  136.             (LAMBDA () ,compiled-function-body)))
  137.             code
  138.             keywords
  139.             (lambda (compiled-code module-vars)
  140.               (loop (cdr protections)
  141.                 compiled-code
  142.                 module-vars))))))))))))
  143.